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-- Statement. mesa, modified by Sweet, Aug 29, 1978 11:37 AM 

DIRECTORY 

AltoDefs: FROM "altodefs" USING [BYTE, wordlength], 

Code: FROM "code" USING [acstack, actenable, catchcount, catchoutrecord , cfs, CodeNotlmplemented, cod 
♦♦eptr, curctxlvl, fileindex, f irstcasesel read , framesz, mwcasesel tlex , StackNotEmptyAtStatement , xtrac 
**ting], 

CodeDefs: FROM "codedefs" USING [BDOIndex, CCIndex, CCItem, ChunkBase, CodeCCIndex, EXLRIndex, FreeCh 
**unk, LabelCCIndex, LabelCCNull, Lexeme, OtherCCIndex , Stklndex, TempStateRecord , topostack], 

ComData: FROM "comdata" USING [textlndex], 

ControlDefs: FROM "controldef s" USING [localbase], 

ErrorDefs: FROM "errordefs" USING [error], 

FOpCodes: FROM "fopcodes" USING [qBCAST, qBCASTL, qBLT, qBLTL, qCATCH, qDADD, qDCOMP, qOSUB, qDEC, qD 
♦♦ST, qINC, qLL, qLP, qLST, qLSTF, qNOTIFY, qNOTIFYL, qPOP, qPUSH, qRET, qSL], 

P5ADefs: FROM "p5adefs" USING [adjustacstack , ccellalloc, Cflow, CioutO, Cioutl, clearstack, computef 
♦♦ramesize, Coutjump, createlabel, Csyserror, genanonlex, genheaplex, getlabelmark, incrstack, insertla 
♦♦bel, labelalloc, loadlexaddress, loadtsonaddress, LogHeapFree, makeEXITlabel , markstack, newstack, P5 
♦♦Error, pop, popinvals, poplabels, poptempstate, purgeheapl ist , purgependtempl ist , pushheapl ist, pusht 
♦♦empstate, releaseBDOItem, releasetemplex, RequireStack, resettomark, restored dstack, rmakeBDOItem, s 
♦♦Cassign, stackoff, stackon, treeliteral, tree! iteral value, unmarkstack, wordsf oroperand] , 

P5BDefs: FROM "p5bdefs" USING [Cexp, MWConstant, pushlex, pushlitval, pushrhs], 

P5StmtExprDef s: FROM "p5stmtexprdef s" USING [Cassign, Ccall, Ccatchmark, Cconstruct, Ccontinue, Cexit- 
♦♦, Cextract, Cgoto, Cjoin, Clabel, Clabelcreate, Clabellist, Cloop, Cprocinit, Crestart, Cresume, Cret 
♦♦ry, Creturn, Crowcons, Csigerr, Cstart, Cstop, Cunlock, Cvconstruct, Cwait, Cxerror], 

SymDefs: FROM "symdefs" USING [bodytype, BTIndex, ContextLevel, CTXIndex, CTXNull, ctxtype, HTIndex, 
♦♦ISEIndex, recordCSEIndex, recordCSENul 1 , SEIndex, SENull , SERecord, setype], 

SymTabDefs: FROM "symtabdefs" USING [WordsForType] , 

SystemDefs: FROM "systemdefs" USING [AllocateHeapNode , FreeHeapNode] , 

TableDefs: FROM "tabledefs" USING [TableBase, TableLimit, TableNotif ier], 

TreeDefs: FROM "treedefs" USING [empty, freetree, "listlength, NodeName, reverseupdatel ist , scanlist, 
♦*setshared, Treelndex, TreeLink, treetype, updatelist]; 

DEFINITIONS FROM FOpCodes, CodeDefs; 

Statement: PROGRAM 

IMPORTS MPtr: ComData, CPtr: Code, CodeDefs, P5ADefs, P5BDefs, P5StmtExprDef s , SymTabDefs, SystemDe 
**fs, TreeDefs, ErrorDefs 

EXPORTS CodeDefs, P5BDefs » 
BEGIN 
OPEN P5ADefs, P5BDefs, P5StmtExprDef s; 

-- imported definitions 

BYTE: TYPE ■ AltoDefs .BYTE ; 

wordlength: CARDINAL = AltoDefs. wordlength; 

ContextLevel: TYPE = SymDefs .ContextLevel ; 

CTXIndex: TYPE = SymDefs .CTXIndex; 

CTXNull: CTXIndex = SymDef s .CTXNul 1 ; 

HTIndex: TYPE = SymDefs .HTIndex; 

ISEIndex: TYPE = SymDefs . ISEIndex ; 

recordCSEIndex: TYPE * SymDefs . recordCSEIndex; 

recordCSENul 1 : recordCSEIndex = SymDefs . recordCSENul 1 ; 

SEIndex: TYPE = SymDefs .SEIndex; 

SENull: SEIndex = SymDef s .SENul 1 ; 

SERecord: TYPE - SymDef s .SERecord; 

BTIndex: TYPE = SymDef s .BTIndex; 

empty: TreeLink * TreeDefs .empty ; 
NodeName: TYPE - TreeDefs .NodeName; 
Treelndex: TYPE * TreeDefs . Treelndex; 
TreeLink: TYPE * TreeDefs. TreeLink ; 

tb: TableDefs. TableBase; -- tree base (local copy) 

seb: TableDefs. TableBase; -- semantic entry base (local copy) 

ctxb: TableDefs . TableBase; -- context entry base (local copy) 

cb: ChunkBase; -- code base (local copy) 

bb: TableDefs. TableBase; -- body base (local copy) 

StatementNotify: PUBLIC TableDefs. TableNotif ier - 

BEGIN -- called by allocator whenever table area is repacked 
seb <- base[SymDefs .setype] ; 
ctxb <- base[SymDefs .ctxtype]; 
tb «- base[TreeDefs . treetype]; 
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cb 4- LOOPHOLE[tb]; 

bb <- base[SymDefs.bodytype] ; 

RETURN 

END; 

CatchFrameTooLarge: SIGNAL ■ CODE; 

Cstatement: PUBLIC PROCEDURE [t: TreeLink] RETURNS[TreeLink] ■ 
BEGIN -- generates code for Mesa statements 
node: Treelndex; 
savheaplist: ISEIndex; 
savelndex: CARDINAL ■ MPtr. textlndex; 

clearstack[]; 

IF t ■ empty THEN RETURN[empty]; 
BEGIN 
ENABLE 
BEGIN 

LogHeapFree => RESUME[TRUE, genheapl ex[]] ; 
CPtr.CodeNotlmplemented *> GO TO unimplementedConstruct 
END; 
savheaplist «- pushheapl ist[] ; 
WITH t SELECT FROM 
subtree «> 
BEGIN 

node <- index; 

CPtr.f ileindex <- MPtr. textlndex «- ( tb+node) . info; 
IF CPtr.acstack # THEN 

BEGIN SIGNAL CPtr . StackNotEmptyAtStatement ; CPtr.acstack <- 0; END; 
SELECT (tb+node) .name FROM 
block => Cblock[node]; 
start s > Cstart[node] ; 
restart => Crestart[node]; 
stop => Cstop[node]; 
dst => Cdst[node]; 
1st => Clst[node]; 
lstf => Clstf[node]; 
call, portcall «> Ccall[node]; 
signal, error => Csigerr[node]; 
syserror => Csyserror[]; 
label => Clabel[node]; 
assign => Cassign[node]; 
extract => Cextract[node]; 
ifstmt -> Cifstmt[node]; 

casestmt => [] «- Ccasestmtexp[node, FALSE]; 
dostmt => Cdostmt[node]; 
exit => Cexit[]; 
loop => Cloop[]; 
retry -> Cretry[]; 
construct => Cconstruct[node]; 
vconstruct ~> Cvconstruct[node]; 
continue => Ccontinue[]; 
goto => Cgoto[node]; 
catchmark -> Ccatchmark[node]; 
rowcons -> Crowcons[node]; 
return => Creturn[node]; 
resume => Cresume[node]; 
openstmt -> Copen[node]; 
enable -> Cenable[node]; 
procinit => Cprocinit[node] ; 
wait -> Cwait[node]; 
notify => Cnotify[node]; 
broadcast => Cbroadcast[node]; 
join => Cjoin[node]; 
unlock => Cunlock[node]; 
xerror *> Cxerror[node]; 
nullstmt => NULL; 

list = > t *- TreeDef s. update! ist[t, Cstatement]; 
ENDCASE => GO TO unimplementedConstruct; 
END; 
ENDCASE; 
purgeheapl ist[savheapl ist]; 
purgependtempl ist[]; 
EXITS 

unimplementedConstruct a > 
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BEGIN 

ErrorDefs . err or [un implemented]; 

CPtr.acstack «- 0; 

clearstack[]; 

END; 
END; 

MPtr .textlndex «- savelndex; 
[] ♦- TreeDefs.freetree[t]; 
RETURN[empty] 
END; 

Copen: PROCEDURE [node: Treelndex] ■ 
BEGIN 

OPEN TreeDefs; 
sCopen: PROCEDURE [t: TreeLink] RETURNS [TreeLink] ■ 

BEGIN 

setshared[t, FALSE]; 

RETURN[freetree[t]] 

END; 

(tb+node) . son2 <- Cstatement[(tb+node) .son2] ; 

(tb+node) .sonl <- reverseupdatel ist[( tb+node) . sonl , sCopen]; 

RETURN 

END; 

Cdst: PROCEDURE [node: Treelndex] ■ 
BEGIN -- generates dumpstate 
dlstate[node, qDST]; 
RETURN 
END; 

Cist: PROCEDURE [node: Treelndex] ■ 
BEGIN — generates loadstate 
dlstate[node, qLST]; 
RETURN 
END; 

Clstf: PROCEDURE [node: Treelndex] « 
BEGIN -- generates loadstateandf ree 
dlstate[node, qLSTF]; 
Coutjump[JumpRet, LabelCCNull]; 
RETURN 
END; 

InvalidStateStorageLocation: SIGNAL « CODE; 

dlstate: PROCEDURE [node: Treelndex, ope: BYTE] - 

BEGIN -- does state move after checking for small currentcontext address 
r: BDOIndex; 

r <- rmakeBDOItem[Cexp[(tb+node) .sonl]]; 
IF cb[r].tag # o OR cb[r] .offset . level # CPtr .curctxlvl 
OR cb[r]. offset. posn.wd ~IN[0..377B] THEN 
SIGNAL InvalidStateStorageLocation; 
Cioutl[opc, cb[r] .of f set .posn.wd] ; 
releaseBDOItem[r]; 
RETURN 
END; 

Cblock: PROCEDURE [node: Treelndex] - 
BEGIN 

bti: BTIndex <- (tb+node) . info; 
WITH (bb+bti).info SELECT FROM 

Internal s > CPtr .f ileindex ♦■ MPtr . textlndex <- sourcelndex; 
ENDCASE; 
ccel lal locfother]; 
cb[LOOPHOLE[CPtr.codeptr, OtherCCIndex]] .obody ♦■ 

startbody[index: bti]; 
(tb+node) .sonl +- TreeDefs. update! ist[(tb+node) .sonl, Cstatement]; 
( tb+node) .son2 <- TreeDefs. update! ist[( tb+node) ,son2, Cstatement]; 
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ccellalloc[other]; 

cb[LOOPHOLE[CPtr.codeptr, OtherCCIndex]].obody ♦- 

endbody[index: bti]; 
END; 

Cifstmt: PROCEDURE [node: Treelndex] = 

BEGIN -- generates code for an IF statement 
ilabel ,el abel : LabelCCIndex; 

elabel<~iabelalloc[]; 
Cflow[(tb+node).sonl, FALSE, elabel]; 
(tb+node) .son2 4- Cstatement[(tb+node) . son2] ; 
IF (tb+node). son3 # empty THEN 

BEGIN 

Coutjump[Jump, i labels-label all oc[]]; 

insertlabel[elabel ]; 

(tb+node) .son3 <- Cstatement[(tb+node) .son3]; 

insertlabel[ilabel]; 

END 
ELSE insertlabel[elabel]; 
RETURN 
END; 

Ccasestmtexp: PUBLIC PROCEDURE [node: Treelndex, iscasexp: BOOLEAN] RETURNS [valpsize: CARDINAL] * 
BEGIN -- generate code for CASE statment and expression 
casendlabel: LabelCCIndex «- labelalloc[]; 
caselpendlabel : LabelCCIndex 4- label al loc[] ; 
mw: BOOLEAN <- FALSE; 

nswords: CARDINAL <- wordsforoperand[( tb+node) . sonl] ; 
nwords: CARDINAL «- 

IF iscasexp THEN SymTabDefs .WordsForType[( tb+node) . info] ELSE 0; 
savmwcasesel tlex: se Lexeme <- CPtr. mwcasesel tlex; 
savxtracting: BOOLEAN <- CPtr . xtracting ; 
savf irstcaseselread: BOOLEAN 4- CPtr . f irstcaseselread; 
selpsize, endcasepsize: CARDINAL; 
tlex: se Lexeme «- topostack; 
sCitem: PROCEDURE [t: TreeLink] - 
BEGIN 
WITH t SELECT FROM 

subtree => valpsize «- MAX[Ccaseitem[index, iscasexp, FALSE, nwords, casendlabel, caselpendlabel 
**], valpsize]; 
ENDCASE; 
IF iscasexp THEN resettomark[]; 
RETURN 
END; 

CPtr. xtracting «- CPtr .f irstcaseselread *■ FALSE; 

RequireStack[0] ; 

IF iscasexp THEN markstack[]; 

IF nswords = 2 THEN 

BEGIN 

CPtr .mwcasesel tlex <- genanonlex[2]; 

pustirhs[( tb+node) . sonl]; 

sCassign[CPtr .mwcasesel tlex.lexsei]; 

CPtr .f irstcaseselread <~ TRUE; 

mw 4- TRUE; 

END 
ELSE IF nswords > 2 THEN 

BEGIN 

CPtr .mwcasesel tlex «- genanonlex[nswords]; 

selpsize *- loadtsonaddress[(tb+node) . sonl]; 

pushlitval [nswords] ; 

[] 4- loadlexaddress[CPtr .mwcasesel tlex]; 

IF selpsize # wordlength THEN 

BEGIN CioutO[qLP]; CioutO[qBLTL] END 

ELSE CioutO[qBLT]; 

mw 4- TRUE; 

END 
ELSE BEGIN pushrhs[( tb+node) . sonl] ; CPtr .f irstcasesel read 4- TRUE; END; 
valpsize 4- wordlength; 
BEGIN ENABLE 

BEGIN 

LogHeapFree •»> IF iscasexp THEN RESUME[FALSE, topostack]; 

MWConstant *> IF iscasexp THEN 
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BEGIN 

IF tlex ■ topostack THEN tlex <- genanonlex[nwords] ; 
RESUME[tlex]; 
END 
END; 

TreeDef s . scanl ist[( tb+node) . son 2, sCitem] ; 
IF iscasexp THEN 
BEGIN 

IF nwords > 2 THEN 
BEGIN 

endcasepsize <- loadtsonadclress[(tb+node) . son3]; 

Coutjump[Jump, IF endcasepsize > wordlength THEN easel pendl abel ELSE casendl abel ] ; 
END 
ELSE pushrhs[(tb+node) .son3] ; 
unmarkstack[]; 
END 
ELSE (tb+node) ,son3 «- Cstatement[(tb+node) ,son3] ; 
END; 

insert! abel [casendl abel]; 
IF valpsize > wordlength THEN CioutO[qLP]; 
insertl abel [easel pendl abel ] ; 
IF mw THEN rel easetemplex[CPtr .mwcasesel tlex] ; 
CPtr.mwcasesel tlex «- savmwcasesel tlex; 
CPtr. f irstcaseselread <- savf irstcaseselread; 
CPtr .xtracting <- savxtracting; 

(tb+node) .sonl <- TreeDef s .freetree[( tb+node) . sonl] ; 
(tb+node) .son2 <- TreeDef s .freetree[( tb+node) . son2] ; 
(tb+node) .son3 «- TreeDef s .freetree[( tb+node) . son3] ; 

IF (tb+node). nsons > 3 THEN TreeDef s . setshared[(tb+node) . son4, FALSE]; 
IF tlex # topostack THEN releasetemplex[tlex] ; 
RETURN 
END; 

newbranches: PROCEDURE [t: TreeLink, itemlabel, faillabel: LabelCCIndex, 
bt: DESCRIPTOR FOR ARRAY OF LabelCCIndex] 
RETURNS [new: BOOLEAN] = 
BEGIN -- sees if any new branches need to be added to branch table 
i: CARDINAL; 

snb: PROCEDURE [t: TreeLink] - 
BEGIN 

i <- tree! iteralvalue[t]; 
IF bt[i] = faillabel THEN 

BEGIN bt[i] *- itemlabel; new *- TRUE; END; 
RETURN 
END; 

new <- FALSE; 

TreeDef s. scanl ist[t, snb]; 

RETURN 

END; 

Cbranch: PROCEDURE [node: Treelndex, isexp: BOOLEAN, nwords: CARDINAL, casendlabel, easel pendlabel : L 
**abelCCIndex] RETURNS [valpsize: CARDINAL] - 

BEGIN -- generate code for case switch if range is densely packed 

range, i: CARDINAL; 

btcp, savcodeptr: CCIndex; 

faillabel : LabelCCIndex; 

bt: DESCRIPTOR FOR ARRAY OF LabelCCIndex; 

scb: PROCEDURE [t: TreeLink] ■ 

BEGIN 

bnode: Treelndex; 

itemlabel: LabelCCIndex; 

vpsize: CARDINAL <- wordlength; 

WITH t SELECT FROM 
subtree ■> 
BEGIN 

bnode ♦• index; 
itemlabel <- labelalloc[]; 

IF newbranches[(tb+bnode). sonl, itemlabel, faillabel, bt] THEN 
BEGIN 

insert label [itemlabel]; 
IF isexp THEN 
BEGIN 
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IF nwords > 2 THEN 

BEGIN vpsize ♦- loadtsonaddress[(tb+bnode) . son2] ; 
ad j us tacstack[-(vp size/word length)]; 
END 
ELSE 

BEGIN pushrhs[(tb+bnode) . son2] ; adjustacstack[-nwords] ; END; 
resettomark[]; 
END 
ELSE (tb+bnode).son2 <- Cstatement[(tb+bnode) . son2]; 
Coutjump[Jump, IF vpsize > wordlength THEN casendlabel 

ELSE caselpendlabel]; 
END 
ELSE CodeDefs.FreeChunk[itemlabe1 , SIZE[label CCItem]]; 
IF vpsize # wordlength THEN valpsize <- vpsize; 
RETURN 
END; 
ENDCASE 
END; 

valpsize «- wordlength; 

range <- tree! iteralvalue[(tb+node) .son2]; 

faillabel *- labelalloc[]; 

pushrhs[( tb+node) .sonl]; 

RequireStack[l]; 

push! itval[range] ; 

adjustacstack[-2]; 

pop[]; pop[]; 

ccel lal loc[other]; 

cb[LOOPHOLE[CPtr.codeptr, OtherCCIndex]] .obody ♦- 

table[btab: , tablecodebytes: 3, taboffset: ]; 
btcp «- CPtr . codeptr ; 
Coutjump[JumpCA, faillabel]; 

bt <- DESCRIPTOR[SystemDefs.AllocateHeapNode[range] t range]; 
FOR i IN [0.. range) DO bt[i] ♦■ faillabel ENDLOOP; 
TreeDef s .scan! ist[(tb+node) . son3 , scb] ; 
savcodeptr «- CPtr. codeptr; 
CPtr. codeptr ♦- btcp; 

FOR i IN [0.. range) DO Cout jump[JumpC, bt[i]] ENDLOOP; 
CPtr. codeptr *- savcodeptr; 
insert! abel [faillabel ] ; 
SystemDefs.FreeHeapNode[BASE[bt]]; 
RETURN 
END; 

Ccaseitem: PROCEDURE [node: Treelndex, isexp, isenable: BOOLEAN, nwords: CARDINAL, casendlabel, caselp 
"endlabel: LabelCCIndex] RETURNS [valpsize: CARDINAL] = 
BEGIN -- generate code for a CASE item 
itemlabel, faillabel: LabelCCIndex; 
irecord, savcatchoutrecord: recordCSEIndex; 

sei: POINTER [0. . TableDef s . TableLimi t) TO transfer constructor SERecord; 
savinctxlevel , savoutctxlevel : ContextLevel ; 
ictx, octx: CTXIndex <- CTXNull; 
lasson: CARDINAL; 
thisson: CARDINAL «- 0; 
sci: PROCEDURE [t: TreeLink] - 
BEGIN 

IF thisson # lasson THEN 
BEGIN 

Cflow[t, TRUE, itemlabel]; 
thisson *- thisson+1; 
END 
ELSE 
BEGIN 

Cflow[t, FALSE, faillabel]; 
insertl abel [item! abel]; 
END; 
RETURN 
END; 

IF (tb+node) . name ■ caseswitch THEN 

RETURN[Cbranch[node, isexp, nwords, casendlabel, caselpendlabel]]; 
valpsize <- wordlength; 
faillabel ♦- labelalloc[]; 
WITH tl: (tb+node). sonl SELECT FROM 

subtree *> 
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BEGIN 

itemlabel «- labelalloc[]; 

IF (tb+tl. index) .name # list THEN lasson «- 
ELSE lasson <- TreeDef s . 1 istlength[tl]-l; 
TreeDefs. scanlist[tl, sci]; 
END; 
ENDCASE => Cflow[tl, FALSE, faillabel]; 
IF isexp THEN 

IF nwords > 2 THEN 
BEGIN 

valpsize «- loadtsonaddress[(tb+node) ,son2]; 
adjustacstack[-(valpsize/wordlength)]; 
END 
ELSE 

BEGIN pushrhs[(tb+node) ,son2]; adjustacstack[-nwords] ; END 
ELSE 

IF isenable THEN 
BEGIN 

savcatchoutrecord «- CPtr .catchoutrecord; 
sei <- (tb+node) . info; 
IF sei § SENull THEN 
BEGIN 

irecord <- (seb+sei ) . inrecord; 
CPtr. catchoutrecord «- (seb+sei) .outrecord; 
IF irecord § recordCSENul 1 THEN 
BEGIN 

ictx «- (seb+irecord) .f ieldctx; 
savinctxlevel <- (ctxb+ictx) .ctxleve! ; 
(ctxb+ictx) . ctxlevel <- CPtr .curctxl vl ; 
END; 
IF CPtr. catchoutrecord # recordCSENul! THEN 
BEGIN 

octx «- (seb+CPtr. catchoutrecord) .f ieldctx; 
savoutctxlevel <- (ctxb+octx) .ctxlevel ; 
(ctxb+octx) .ctxlevel <- CPtr .curctxlvl ; 
END; 
END 
ELSE irecord <- CPtr. catchoutrecord <- recordCSENul!; 
popinvals[irecord, TRUE]; 

(tb+node) . son2 <- Cstatement[(tb+node) .son2] ; 
IF ictx # CTXNull THEN (ctxb+ictx) . ctxl eve! <- savinctxlevel; 
IF octx # CTXNull THEN (ctxb+octx) . ctxl eve! <- savoutctxlevel; 
CPtr . catchoutrecord «- savcatchoutrecord; 
END 
ELSE (tb+node) .son2 <- Cstatement[( tb+node) .son2]; 
Coutjump[Jump, IF valpsize a wordlength THEN casendlabel 

ELSE caselpendlabel]; 
insert! abel[faillabel]; 
RETURN 
END; 

Cdostmt: PROCEDURE [rootnode: Treelndex] » 

BEGIN -- generates code for all the loop statments 

steploop, tempindex, tempend, uploop, forseqloop, unsigned, long: BOOLEAN <- FALSE; 
t, Sson, Eson: TreeLink; 
node, node2: Treelndex; 
inttype: NodeName; 
indexlex: se Lexeme; 
endlex: Lexeme; 

toplabel: LabelCCIndex «- labelal loc[]; 
startlabel: LabelCCIndex; 
finlabel: LabelCCIndex «- labela! loc[]; 
endlabel, looplabel: LabelCCIndex; 
labelrnark: EXLRIndex «- get! abelmark[]; 
updateCV: PROCEDURE [loadlong: BOOLEAN] - 
BEGIN 
IF long THEN 

BEGIN 

IF loadlong THEN 

BEGIN RequireStack[0]; push!ex[indexlex]; END 

ELSE RequireStack[2]; 

push! itval[l]; pushl itval[0] ; 

CioutO[IF uploop THEN qDADD ELSE qDSUB]; 

sCassign[ indexlex. lexsei]; 

END 
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ELSE CioutO[IF uploop THEN qINC ELSE qDEC]; 
END; 

-- set up for EXIT clause 

[exit: endlabel, loop: looplabel] «- makeEXITl abel [] ; 
TreeDefs.scanl ist[(tb+rootnode) ,son5, Clabelcreate] ; 

-- handle initialization node 

t «- (tb+rootnode) .sonl; 
WITH t SELECT FROM 
subtree -> 
IF t # empty THEN 
BEGIN 

node «- index; 

SELECT (tb+node) .name FROM 
forseq B > 
BEGIN 

forseqloop ♦• TRUE; 
pushrhs[( tb+node) . son2]; 
insertlabel[toplabel]; 
WITH (tb+node). sonl SELECT FROM 
symbol => sCassign[index]; 
ENDCASE; 
END; 
upthru, downthru ■> 
BEGIN 

steploop <- TRUE; 

uploop «- (tb+node) . name = upthru; 
WITH (tb+node). son2 SELECT FROM 
subtree a > 
BEGIN 

node2 «- index; 
inttype <- (tb+node2) .name; 
IF (tb+node2).attrl THEN 
BEGIN 

long ♦■ TRUE; 

IF (tb+node2).attr2 THEN SIGNAL CPtr .CodeNotlmplemented; 
END 
ELSE unsigned <- (tb+node2) . attr2; 
END; 
ENDCASE; 
WITH (tb+node). sonl SELECT FROM 
subtree a > -- sonl is empty 
BEGIN 

indexlex <- genanonlex[IF long THEN 2 ELSE 1]; 
tempindex <- TRUE; 
END; 
symbol => indexlex «- Lexeme[se[index]] ; 
ENDCASE; 
WITH ( tb+node). son2 SELECT FROM 
subtree *> 
BEGIN 
IF uploop THEN 

BEGIN Sson *- ( tb+node2) . sonl ; Eson <- (tb+node2) . son2; END 
ELSE 
BEGIN 
SELECT inttype FROM 

intCO => inttype «- intOC; 
intOC ■> inttype *- intCO; 
ENDCASE; 
Sson <- (tb+node2) . son2; 
Eson <- (tb+node2) . sonl; 
END; 
WITH e: Eson SELECT FROM 
1 iteral «> 

WITH e.info SELECT FROM 
word s > endlex «- 

Lexeme[l iteral [word[ index]]]; 
ENDCASE -> P5ADefs.P5Error[769]; 
ENDCASE -> 
BEGIN 

pushrhs[e]; tempend «- TRUE; 
sCassign[ 

(endlex <- genanonlex[IF long THEN 2 ELSE l]).lexsei]; 
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END; 
startlabel <- labelalloc[]; 
IF long THEN RequireStack[0] ; 
pushrhs[Sson]; 
IF long THEN 

IF inttype - intOO THEN 

BEGIN adjustacstack[-2]; pop[]; pop[] END 
ELSE sCassign[indexlex.lexsei]; 
IF inttype = intCC AND (tempend OR -tree! i teral[Sson]) THEN 
BEGIN -- earlier passes check for empty intervals 
IF long THEN BEGIN CioutO[qPUSH] ; CioutO[qPUSH] END; 
pushlex[endlex] ; 

IF long THEN BEGIN CioutO[qDCOMP] ; pushl itval [0] END; 
Coutjump[ 

IF unsigned THEN IF uploop THEN UJumpG ELSE UJumpL 
ELSE IF uploop THEN JumpG ELSE JumpL, finlabel]; 
IF -long THEN CioutO[qPUSH] ; 
END; 
IF -long THEN BEGIN adjustacstack[-l] ; pop[]; END; 
Coutjump[Jump, startlabel]; 
insert label [top label]; 
IF -long THEN CioutO[qPUSH] ; 
SELECT inttype FROM 

intCC => BEGIN updateCV[TRUE]; insertlabel [startlabel ] ; END; 
intOC «> updateCV[TRUE]; 
intCO, intOO »> NULL; 
ENDCASE; 
IF -long THEN sCassign[indexlex. lexsei] ; 
END; 
ENDCASE; 
END; 
ENDCASE; 
END 
ELSE insertlabel[toplabel]; 
ENDCASE; 

-- now the pre-body test 

IF (tb+rootnode) .son2 # empty THEN 

Cflow[(tb+rootnode) .son2, FALSE, finlabel]; 

-- ignore the opens 

-- (tb+node).son3; 

-- now the body 

(tb+rootnode) .son4 «- Cstatement[(tb+rootnode) .son4]; 

-- now (update and) test the control variable 

insertlabel [loop label ]; 
IF steploop THEN 
BEGIN 

IF long AND inttype = intOC THEN insert! abel[startlabel]; 
pushlex[indexlex]; 
SELECT inttype FROM 

intCC => NULL; 

intCO => BEGIN updateCV[FALSE] ; insertlabel [startlabel ]; END; 

intOC => IF -long THEN insertlabel [startlabel ] ; 

intOO «> BEGIN insertlabel[startlabel ] ; updateCV[FALSE] ; END; 

ENDCASE; 
IF long THEN SELECT inttype FROM 

intCO, intOO -> BEGIN CioutO[qPUSH] ; CioutO[qPUSH] END; 

ENDCASE; 
pushlex[endlex] ; 

IF long THEN BEGIN CioutO[qDCOMP] ; pushl itval [0] END; 
Coutjump[ 

IF unsigned THEN IF uploop THEN UJumpL ELSE UJumpG 
ELSE IF uploop THEN JumpL ELSE JumpG, toplabel]; 
Coutjump[Jump, finlabel]; 

IF tempend THEN releasetemplex[LOOPHOLE[endlex, se Lexeme]]; 
IF tempindex THEN releasetemplex[indexlex] ; 
END 
ELSE 
BEGIN 
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IF forseqloop THEN 
BEGIN 
WITH (tb+rootnode).sonl SELECT FROM 

subtree s > pushrhs[(tb+index) . son3 I LogHeapFree ■> 

RESUME[FALSE t topostack]]; 
ENDCASE; 
END; 
Coutjump[Jump, toplabel]; 
END; 
clearstack[]; CPtr.acstack <- 0; 

-- now the labelled EXITs 

Clabel list[(tb+rootnode).son5, endlabel]; 
pop! abels[ label mark]; 

— finally the FINISHED clause 

insert! abel[finlabel]; 

(tb+rootnode) . son6 «- Cstatement[(tb+rootnode) . son6]; 

insert! abel [endlabel]; 

RETURN 

END; 



Ccatchphrase: PUBLIC PROCEDURE [node: Treelndex] » 
BEGIN -- process a catchphrase at procedure call 
aroundlabel: LabelCCIndex <- labelalloc[]; 
savcfs: CARDINAL <- CPtr.cfs; 
r: CodeCCIndex; 

CPtr. catchcount <- CPtr .catchcount + 1; 

Cioutl[qCATCH, 0]; 

r «- LOOPHOLE[CPtr.codeptr, CodeCCIndex]; 

Coutjump[JumpA, aroundlabel]; 

sCcatchphrase[node]; 

cb[r] . parameters[l] *- CPtr.cfs; 

insert label [around label]; 

CPtr. catchcount «- CPtr, catchcount - 1; 

CPtr.cfs <- savcfs; 

RETURN 

END; 



Cenable: PROCEDURE [node: Treelndex] « 
BEGIN -- generate code for an ENABLE 
aroundlabel: LabelCCIndex «- label al loc[] ; 
enablelabel: LabelCCIndex; 
savactenable: LabelCCIndex <- CPtr .actenable; 
savcfs: CARDINAL <- CPtr.cfs; 

CPtr .catchcount <- CPtr .catchcount + 1; 
Cout jump[ Jump A, aroundlabel] ; 
enablelabel <- create!abel[] ; 
WITH (tb+node).sonl SELECT FROM 

subtree => sCcatchphrase[index]; 

ENDCASE; 
insert! abel [aroundlabel]; 
CPtr . actenable «- enablelabel; 
CPtr . catchcount <- CPtr .catchcount -1; 
(tb+node) .son2 ♦- Cstatement[( tb+node) .son2]; 
CPtr . actenable «- savactenable; 
CPtr.cfs <- savcfs; 
RETURN 
END; 



sCcatchphrase: PUBLIC PROCEDURE [node: Treelndex] ■ 
BEGIN -- main subr for catchphrases and ENABLES 
savf irstcaseselread: BOOLEAN «- CPtr . f irstcaseselread; 
endlabel: LabelCCIndex <- labelalloc[]; 
oldstkptr: Stklndex <- newstack[]; 
msgtemp, sigtemp: se Lexeme; 
savactenable: LabelCCIndex; 
tempstate: TempStateRecord; 
sscc: PROCEDURE [t: TreeLink] - 
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BEGIN 

WITH t SELECT FROM 

subtree »> [] ♦* Ccaseitem[ 

node: index, isexp:FALSE, isenab1e:TRUE, 
nwords:0, casendlabel :endl abel , caselpendlabel :endlabel ]; 
ENDCASE; 
RETURN 
END; 

CPtr.curctxIvl «- CPtr.curctxIvl + 1; 

push temp state[ ©temp state, (tb+node) .info]; 

IF CPtr.actenable # LabelCCNull THEN 

BEGIN 

sigtemp «- genanonlex[l]; 

msgtemp <- genanonl ex[l]; 

adjustacstack[l]; incrstack[2] ; 

stackoff[]; Cioutl[qLL,ControlDef s. localbase+1]; stackon[]; 

sCassign[msgtemp. lexsei]; 

sCassign[sigtemp.lexsei]; 

pushlex[sigtemp]; 

adjustacstack[~l]; 

Pop[]; 

END; 
CPtr.f irstcaseselread <- TRUE; 
adjustacstack[l]; 
incrstack[l]; 

savactenable <- CPtr.actenable; 
CPtr.actenable <- LabelCCNull; 
TreeDefs.scanl ist[( tb+node) .sonl, sscc]; 
stackoff[]; 
IF (tb+node). son2 # empty THEN 

BEGIN 

IF (tb+node) .sonl ■ empty THEN CioutO[qPOP]; 

stackon[]; 

(tb+node) .son2 <- Cstatement[(tb+node) .son2]; 

END; 
CPtr.actenable «- savactenable; 
insert! abel [endl abel]; 
stackoff[]; 
IF CPtr.actenable » LabelCCNull THEN 

BEGIN 

pushlex[sigtemp]; 

pushlex[msgtemp]; 

C ioutl[qSL, Con trolDefs. localbase+1]; 

adjustacstack[-l]; 

Cout jump [Jump, CPtr . actenable]; 

release temp lex[msg temp] ; 

release temp lex[sig temp]; 

END 
ELSE 

BEGIN 

pushlitval[0]; 

adjustacstack[-l]; 

CioutO[qRET]; 

Coutjump[JumpRet, LabelCCNull] ; 

END; 
stackon[]; 

CPtr.curctxIvl «- CPtr.curctxlvl-1; 
CPtr . f irstcaseselread <- savf irstcaseselread; 
CPtr.cfs <- CPtr.framesz; 
pop temps t a te[@temp state]; 
CPtr.cfs <- computef ramesize[CPtr .cfs]; 
IF CPtr.cfs > 377B THEN SIGNAL CatchFrameTooLarge; 
restoreoldstack[oldstkptr]; 
RETURN 
END; 

Cnotify: PROCEDURE [node: Treelndex] - 
BEGIN 
CioutO[IF loadtsonaddress[(tb+node).sonl] * wordlength THEN qNOTIFY 

ELSE qNOTIFYL]; 
END; 

Cbroadcast: PROCEDURE [node: Treelndex] - 
BEGIN 
CioutO[IF loadtsonaddress[( tb+node) .sonl] « wordlength THEN qBCAST 
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ELSE qBCASTL]; 
END; 

END... 



